home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / cmpnew / cmpvar.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  17.1 KB  |  464 lines
  1. ;;; CMPVAR  Variables.
  2. ;;;
  3. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  4.  
  5. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  6. ;;
  7. ;; GCL is free software; you can redistribute it and/or modify it under
  8. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  9. ;; the Free Software Foundation; either version 2, or (at your option)
  10. ;; any later version.
  11. ;; 
  12. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  13. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  15. ;; License for more details.
  16. ;; 
  17. ;; You should have received a copy of the GNU Library General Public License 
  18. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  19. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  
  22. (in-package 'compiler)
  23.  
  24. (si:putprop 'var 'c2var 'c2)
  25. (si:putprop 'location 'c2location 'c2)
  26. (si:putprop 'setq 'c1setq 'c1special)
  27. (si:putprop 'setq 'c2setq 'c2)
  28. (si:putprop 'progv 'c1progv 'c1special)
  29. (si:putprop 'progv 'c2progv 'c2)
  30. (si:putprop 'psetq 'c1psetq 'c1)
  31. (si:putprop 'psetq 'c2psetq 'c2)
  32.  
  33. (si:putprop 'var 'set-var 'set-loc)
  34. (si:putprop 'var 'wt-var 'wt-loc)
  35.  
  36. (defstruct var
  37.   name        ;;; Variable name.
  38.   kind        ;;; One of LEXICAL, SPECIAL, GLOBAL, REPLACED, FIXNUM,
  39.           ;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, and OBJECT.
  40.   ref        ;;; Referenced or not.
  41.           ;;; During Pass1, T, NIL, or IGNORE.
  42.           ;;; During Pass2, the vs-address for the variable.
  43.   ref-ccb    ;;; Cross closure reference.
  44.           ;;; During Pass1, T or NIL.
  45.           ;;; During Pass2, the ccb-vs for the variable, or NIL.
  46.   loc        ;;; For SPECIAL and GLOBAL, the vv-index for variable name.
  47.         ;;; For others, this field is used to indicate whether
  48.         ;;; to be allocated on the value-stack: OBJECT means
  49.         ;;; the variable is declared as OBJECT, and CLB means
  50.         ;;; the variable is referenced across Level Boundary and thus
  51.         ;;; cannot be allocated on the C stack.  Note that OBJECT is
  52.         ;;; set during variable binding and CLB is set when the
  53.         ;;; variable is used later, and therefore CLB may supersede
  54.         ;;; OBJECT.
  55.           ;;; For REPLACED, the actual location of the variable.
  56.           ;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, and
  57.           ;;; OBJECT, the cvar for the C variable that holds the value.
  58.           ;;; Not used for LEXICAL.
  59.   (type t)    ;;; Type of the variable.
  60.   (register 0)  ;;; If greater than specified am't this goes into register.
  61.   )
  62.  
  63. ;;; A special binding creates a var object with the kind field SPECIAL,
  64. ;;; whereas a special declaration without binding creates a var object with
  65. ;;; the kind field GLOBAL.  Thus a reference to GLOBAL may need to make sure
  66. ;;; that the variable has a value.
  67.  
  68. (defvar *vars* nil)
  69. (defvar *register-min* 4) ;criteria for putting in register.
  70. (defvar *undefined-vars* nil)
  71. (defvar *special-binding* nil)
  72.  
  73. ;;; During Pass 1, *vars* holds a list of var objects and the symbols 'CB'
  74. ;;; (Closure Boundary) and 'LB' (Level Boundary).  'CB' will be pushed on
  75. ;;; *vars* when the compiler begins to process a closure.  'LB' will be pushed
  76. ;;; on *vars* when *level* is incremented.
  77. ;;; *GLOBALS* holds a list of var objects for those variables that are
  78. ;;; not defined.  This list is used only to suppress duplicated warnings when
  79. ;;; undefined variables are detected.
  80.  
  81. (defun c1make-var (name specials ignores types &aux x)
  82.   (let ((var (make-var :name name)))
  83.        (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
  84.        (cmpck (constantp name) "The constant ~s is being bound." name)
  85.  
  86.        (cond ((or (member name specials) (si:specialp name))
  87.               (setf (var-kind var) 'SPECIAL)
  88.               (setf (var-loc var) (add-symbol name))
  89.               (cond ((setq x (assoc name types))
  90.                      (setf (var-type var) (cdr x)))
  91.                     ((setq x (get name 'cmp-type))
  92.                      (setf (var-type var) x)))
  93.               (setq *special-binding* t))
  94.              (t
  95.           (dolist** (v types)
  96.             (cond ((eq (car v) name)
  97.                    (case (cdr v)
  98.                      (object (setf (var-loc var) 'object))
  99.                      (register
  100.                       (setf (var-register var)
  101.                         (+ (var-register var) 100)))
  102.                      (t (setf (var-type var) (cdr v)))))))
  103.           (and (boundp '*c-gc*) *c-gc*
  104.            (or (null (var-type var))
  105.                (eq t (var-type var)))
  106.            (setf (var-loc var) 'object))
  107.               (setf (var-kind var) 'LEXICAL)))
  108.        (when (member name ignores) (setf (var-ref var) 'IGNORE))
  109.        var)
  110.   )
  111.  
  112. (defun check-vref (var)
  113.   (when (and (eq (var-kind var) 'LEXICAL)
  114.              (not (var-ref var)) ;;; This field may be IGNORE.
  115.              (not (var-ref-ccb var)))
  116.         (cmpwarn "The variable ~s is not used." (var-name var))))
  117.  
  118. (defun c1var (name)
  119.   (let ((info (make-info))
  120.         (vref (c1vref name)))
  121.        (push (car vref) (info-referred-vars info))
  122.        (setf (info-type info) (var-type (car vref)))
  123.        (list 'var info vref))
  124.   )
  125.  
  126. ;;; A variable reference (vref for short) is a pair
  127. ;;;    ( var-object  ccb-reference )
  128.  
  129. (defun c1vref (name &aux (ccb nil) (clb nil))
  130.        (declare (object ccb clb))
  131.   (dolist* (var *vars*
  132.                (let ((var (sch-global name)))
  133.                     (unless var
  134.                       (unless (si:specialp name) (undefined-variable name))
  135.                       (setq var (make-var :name name
  136.                                           :kind 'GLOBAL
  137.                                           :loc (add-symbol name)
  138.                                           :type (or (get name 'cmp-type) t)
  139.                                           ))
  140.                       (push var *undefined-vars*))
  141.                     (list var ccb)))
  142.       (cond ((eq var 'cb) (setq ccb t))
  143.             ((eq var 'lb) (setq clb t))
  144.             ((eq (var-name var) name)
  145.              (when (eq (var-ref var) 'IGNORE)
  146.                    (cmpwarn "The ignored variable ~s is used." name)
  147.                    (setf (var-ref var) t))
  148.              (cond (ccb (setf (var-ref-ccb var) t))
  149.                    (clb (when (eq (var-kind var) 'lexical)
  150.                               (setf (var-loc var) 'clb))
  151.                         (setf (var-ref var) t))
  152.                    (t (setf (var-ref var) t)
  153.               (setf (var-register var)
  154.                 (the fixnum (+ 1 (the fixnum (var-register var)))))
  155.               ))
  156.              (return-from c1vref (list var ccb)))))
  157.   )
  158.  
  159. (defun c2var-kind (var)
  160.   (if (and (eq (var-kind var) 'LEXICAL)
  161.            (not (var-ref-ccb var))
  162.            (not (eq (var-loc var) 'clb)))
  163.       (if (eq (var-loc var) 'OBJECT)
  164.           'OBJECT
  165.           (let ((type (var-type var)))
  166.                (declare (object type))
  167.                (cond ((type>= 'fixnum type) 'FIXNUM)
  168.              ((type>= 'integer type) 'INTEGER)
  169.                      ((type>= 'CHARACTER type) 'CHARACTER)
  170.                      ((type>= 'long-float type) 'LONG-FLOAT)
  171.                      ((type>= 'short-float type) 'SHORT-FLOAT)
  172.                      ((and (boundp '*c-gc*) *c-gc* 'OBJECT))
  173.              (t nil))))
  174.       nil)
  175.   )
  176.  
  177. (defun c2var (vref) (unwind-exit (cons 'var vref) nil 'single-value))
  178.  
  179. (defun c2location (loc) (unwind-exit loc nil 'single-value))
  180.  
  181.  
  182. (defun check-downward (vars &aux no-down )
  183.   (dolist (v *local-functions*)
  184.       (cond ((eq (car v) 'function)
  185.          (setq no-down t)
  186.          (dolist (w *local-functions*)
  187.              (cond ((eq (car w) 'downward-function)
  188.                 (setf (car w) 'function))))
  189.          (return nil))))
  190.   (setq *local-functions* nil)
  191.   (cond (no-down
  192.     (dolist (var vars)
  193.         (if (eq (var-kind var) 'down)
  194.             (setf (var-kind var) 'lexical))))))
  195.  
  196.  
  197. (defun assign-down-vars(vars cfun inside &aux (ind 0) )
  198.   (dolist (var vars)
  199.       (cond ((eq (var-kind var) 'down)
  200.          ;;don't do twice since this list may have duplicates.
  201.          (cond ((integerp (var-loc var) )
  202.             ;(or (integerp (var-ref var)) (print var))
  203.             (setq ind (max ind (1+ (var-loc var))))
  204.             (setf (var-ref var) (var-loc var)) ;delete later
  205.             )
  206.                ;((integerp (var-loc var)) (break "bil"))
  207.                (t (setf (var-ref var) ind) ;delete later
  208.               (setf (var-loc var) ind)
  209.               (setf ind (+ ind 1)))))))
  210.   (cond ((> ind 0)   
  211.      ;;(wt-nl "object Dbase[" ind "];")
  212.      (cond ((eq inside 't3defun)
  213.         (wt-nl "object base0[" ind "];")))
  214.                     ;DCnames gets defined at end whe
  215.      (push 'dcnames *downward-closures*)
  216.      (wt-nl "DCnames"cfun  "")))
  217.   ind)
  218.  
  219. (si::putprop 'down   'wt-down 'wt-loc)
  220.  
  221. (defun wt-down (n)
  222.   (or (si::fixnump n) (wfs-error))
  223.   (wt "base0[" n "]"))
  224.  
  225. (defun wt-var (var ccb)
  226.   (case (var-kind var)
  227.         (LEXICAL (cond (ccb (wt-ccb-vs (var-ref-ccb var)))
  228.                        ((var-ref-ccb var) (wt-vs* (var-ref var)))
  229.                ((and (eq t (var-ref var)) 
  230.                  (si:fixnump (var-loc var))
  231.                  *c-gc*
  232.                  (eq t (var-type var)))
  233.             (setf (var-kind var) 'object)
  234.             (wt-var var ccb))
  235.                        (t (wt-vs (var-ref var)))))
  236.         (SPECIAL (wt "(VV[" (var-loc var) "]->s.s_dbind)"))
  237.         (REPLACED (wt (var-loc var)))
  238.     (DOWN  (wt-down (var-loc var)))
  239.         (GLOBAL (if *safe-compile*
  240.                     (wt "symbol_value(VV[" (var-loc var) "])")
  241.                     (wt "(VV[" (var-loc var) "]->s.s_dbind)")))
  242.         (t (case (var-kind var)
  243.                  (FIXNUM (when (zerop *space*) (wt "CMP"))
  244.                          (wt "make_fixnum"))
  245.          (INTEGER (wt "make_integer")) 
  246.                  (CHARACTER (wt "code_char"))
  247.                  (LONG-FLOAT (wt "make_longfloat"))
  248.                  (SHORT-FLOAT (wt "make_shortfloat"))
  249.                  (OBJECT)
  250.                  (t (baboon)))
  251.            (wt "(V" (var-loc var) ")"))
  252.         ))
  253.  
  254. (defun set-var (loc var ccb)
  255.   (unless (and (consp loc)
  256.                (eq (car loc) 'var)
  257.                (eq (cadr loc) var)
  258.                (eq (caddr loc) ccb))
  259.           (case (var-kind var)
  260.             (LEXICAL (wt-nl)
  261.                      (cond (ccb (wt-ccb-vs (var-ref-ccb var)))
  262.                            ((var-ref-ccb var) (wt-vs* (var-ref var)))
  263.                            (t (wt-vs (var-ref var))))
  264.                      (wt "= " loc ";"))
  265.             (SPECIAL (wt-nl "(VV[" (var-loc var) "]->s.s_dbind)= " loc ";"))
  266.             (GLOBAL
  267.              (if *safe-compile*
  268.                  (wt-nl "setq(VV[" (var-loc var) "]," loc ");")
  269.                  (wt-nl "(VV[" (var-loc var) "]->s.s_dbind)= " loc ";")))
  270.         (DOWN
  271.           (wt-nl "") (wt-down (var-loc var))
  272.           (wt "=" loc ";"))
  273.         (INTEGER
  274.          (let ((first (and (consp loc) (car loc)))
  275.            (n (var-loc var)))
  276.            (case first
  277.          (inline-fixnum
  278.           (wt-nl "ISETQ_FIX(V"n",V"n"alloc,")
  279.           (wt-inline-loc (caddr loc) (cadddr loc)))
  280.          (fixnum-value (wt-nl "ISETQ_FIX(V"n",V"n"alloc,"(caddr loc)))
  281.  
  282.          (var
  283.           (case (var-kind (cadr loc))
  284.             (integer (wt "SETQ_II(V"n",V"n"alloc,V" (var-loc (cadr loc))))
  285.             (fixnum  (wt "ISETQ_FIX(V"n",V"n"alloc,V" (var-loc (cadr loc))))
  286.             (otherwise (wt "SETQ_IO(V"n",V"n"alloc,"loc ))))
  287.          (vs (wt "SETQ_IO(V"n",V"n"alloc,"loc ))
  288.          (otherwise
  289.           (let ((*inline-blocks* 0) (*restore-avma* *restore-avma*))
  290.             (save-avma '(nil integer))
  291.             (wt-nl "SETQ_II(V"n",V" n"alloc,")
  292.             (wt-integer-loc loc  (cons 'set-var var))
  293.             (wt ");")
  294.             (close-inline-blocks))
  295.           (return-from set-var nil))
  296.           )
  297.            (wt ");")))
  298.             (t
  299.              (wt-nl "V" (var-loc var) "= ")
  300.              (case (var-kind var)
  301.                    (FIXNUM (wt-fixnum-loc loc))
  302.                    (CHARACTER (wt-character-loc loc))
  303.                    (LONG-FLOAT (wt-long-float-loc loc))
  304.                    (SHORT-FLOAT (wt-short-float-loc loc))
  305.                    (OBJECT (wt-loc loc))
  306.                    (t (baboon)))
  307.              (wt ";"))
  308.             )))
  309.  
  310. (defun sch-global (name)
  311.   (dolist* (var *undefined-vars* nil)
  312.     (when (eq (var-name var) name) (return-from sch-global var))))
  313.  
  314. (defun c1add-globals (globals)
  315.   (dolist** (name globals)
  316.     (push (make-var :name name
  317.                     :kind 'GLOBAL
  318.                     :loc (add-symbol name)
  319.                     :type (let ((x (get name 'cmp-type))) (if x x t))
  320.                     )
  321.           *vars*))
  322.   )
  323.  
  324. (defun c1setq (args)
  325.   (cond ((endp args) (c1nil))
  326.         ((endp (cdr args)) (too-few-args 'setq 2 1))
  327.         ((endp (cddr args)) (c1setq1 (car args) (cadr args)))
  328.         (t
  329.          (do ((pairs args (cddr pairs))
  330.               (forms nil))
  331.              ((endp pairs) (c1expr (cons 'progn (reverse forms))))
  332.              (declare (object pairs))
  333.              (cmpck (endp (cdr pairs))
  334.                     "No form was given for the value of ~s." (car pairs))
  335.              (push (list 'setq (car pairs) (cadr pairs)) forms)
  336.              )))
  337.   )
  338.  
  339. (defun c1setq1 (name form &aux (info (make-info)) type form1 name1)
  340.   (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name)
  341.   (cmpck (constantp name) "The constant ~s is being assigned a value." name)
  342.   (setq name1 (c1vref name))
  343.   (push (car name1) (info-changed-vars info))
  344.   (setq form1 (c1expr form))
  345.   (add-info info (cadr form1))
  346.   (setq type (type-and (var-type (car name1)) (info-type (cadr form1))))
  347.   (when (null type)
  348.         (cmpwarn "Type mismatches between ~s and ~s." name form))
  349.   (unless (eq type (info-type (cadr form1)))
  350.     (let ((info1 (copy-info (cadr form1))))
  351.          (setf (info-type info1) type)
  352.          (setq form1 (list* (car form1) info1 (cddr form1)))))
  353.   (setf (info-type info) type)
  354.   (list 'setq info name1 form1)
  355.   )
  356.  
  357. (defun c2setq (vref form)
  358.   (let ((*value-to-go* (cons 'var vref))) (c2expr* form))
  359.   (case (car form)
  360.         (LOCATION (c2location (caddr form)))
  361.         (otherwise (unwind-exit (cons 'var vref))))
  362.   )
  363.  
  364. (defun c1progv (args &aux symbols values (info (make-info)))
  365.   (when (or (endp args) (endp (cdr args)))
  366.         (too-few-args 'progv 2 (length args)))
  367.   (setq symbols (c1expr* (car args) info))
  368.   (setq values (c1expr* (cadr args) info))
  369.   (list 'progv info symbols values (c1progn* (cddr args) info))
  370.   )
  371.  
  372. (defun c2progv (symbols values body
  373.                 &aux (cvar (next-cvar))
  374.                      (*unwind-exit* *unwind-exit*))
  375.  
  376.   (wt-nl "{object symbols,values;")
  377.   (wt-nl "bds_ptr V" cvar "=bds_top;")
  378.   (push cvar *unwind-exit*)
  379.  
  380.   (let ((*vs* *vs*))
  381.        (let ((*value-to-go* (list 'vs (vs-push))))
  382.             (c2expr* symbols)
  383.             (wt-nl "symbols= " *value-to-go* ";"))
  384.  
  385.        (let ((*value-to-go* (list 'vs (vs-push))))
  386.             (c2expr* values)
  387.             (wt-nl "values= " *value-to-go* ";"))
  388.  
  389.        (wt-nl "while(!endp(symbols)){")
  390.        (when *safe-compile*
  391.              (wt-nl "if(type_of(MMcar(symbols))!=t_symbol)")
  392.              (wt-nl
  393.               "FEinvalid_variable(\"~s is not a symbol.\",MMcar(symbols));"))
  394.        (wt-nl "if(endp(values))bds_bind(MMcar(symbols),OBJNULL);")
  395.        (wt-nl "else{bds_bind(MMcar(symbols),MMcar(values));")
  396.        (wt-nl "values=MMcdr(values);}")
  397.        (wt-nl "symbols=MMcdr(symbols);}")
  398.        )
  399.   (c2expr body)
  400.   (wt "}")
  401.   )
  402.  
  403. (defun c1psetq (args &aux (vrefs nil) (forms nil)
  404.                           (info (make-info :type '(member nil))))
  405.   (do ((l args (cddr l)))
  406.       ((endp l))
  407.       (declare (object l))
  408.       (cmpck (not (symbolp (car l)))
  409.              "The variable ~s is not a symbol." (car l))
  410.       (cmpck (constantp (car l))
  411.              "The constant ~s is being assigned a value." (car l))
  412.       (cmpck (endp (cdr l))
  413.              "No form was given for the value of ~s." (car l))
  414.       (let* ((vref (c1vref (car l)))
  415.              (form (c1expr (cadr l)))
  416.              (type (type-and (var-type (car vref))
  417.                              (info-type (cadr form)))))
  418.             (unless (equal type (info-type (cadr form)))
  419.               (let ((info1 (copy-info (cadr form))))
  420.                    (setf (info-type info1) type)
  421.                    (setq form (list* (car form) info1 (cddr form)))))
  422.             (push vref vrefs)
  423.             (push form forms)
  424.             (push (car vref) (info-changed-vars info))
  425.             (add-info info (cadar forms)))
  426.       )
  427.   (list 'psetq info (reverse vrefs) (reverse forms))
  428.   )
  429.  
  430. (defun c2psetq (vrefs forms &aux (*vs* *vs*) (saves nil) (blocks 0))
  431.   (dolist** (vref vrefs)
  432.     (if (or (args-info-changed-vars (car vref) (cdr forms))
  433.             (args-info-referred-vars (car vref) (cdr forms)))
  434.         (case (caar forms)
  435.           (LOCATION (push (cons vref (caddar forms)) saves))
  436.           (otherwise
  437.             (if (member (var-kind (car vref))
  438.                         '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT))
  439.                 (let* ((kind (var-kind (car vref)))
  440.                        (cvar (next-cvar))
  441.                        (temp (list 'var (make-var :kind kind :loc cvar) nil)))
  442.                   (wt-nl "{" *volatile* (rep-type kind) "V" cvar ";")
  443.                   (incf blocks)
  444.                   (let ((*value-to-go* temp)) (c2expr* (car forms)))
  445.                   (push (cons vref temp) saves))
  446.                 (let ((*value-to-go* (list 'vs (vs-push))))
  447.                   (c2expr* (car forms))
  448.                   (push (cons vref *value-to-go*) saves)))))
  449.         (let ((*value-to-go* (cons 'var vref))) (c2expr* (car forms))))
  450.     (pop forms))
  451.   (dolist** (save saves) (set-var (cdr save) (caar save) (cadar save)))
  452.   (dotimes (i blocks) (wt "}"))
  453.   (unwind-exit nil)
  454.   )
  455. (defun wt-var-decl (var)
  456.   (cond ((var-p var)
  457.      (let ((n (var-loc var)))
  458.        (cond ((eq (var-kind var) 'integer)(wt "IDECL(")))
  459.        (wt *volatile* (register var) (rep-type (var-kind var))
  460.            "V" n )
  461.        (if (eql (var-kind var) 'integer) (wt ",V"n"space,V"n"alloc)"))
  462.        (wt ";")))
  463.         (t (wfs-error))))
  464.